home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1993…stman Always Clicks Twice / ADC Developer CD (1993-01) (''The Postman Always Clicks Twice'')_iso / Dev.CD 199301.iso / Development Platforms / LISP Related / LISP Goodies / matt's utils 8sept / resource-utils.Lisp < prev    next >
Encoding:
Text File  |  1992-08-16  |  19.8 KB  |  552 lines  |  [TEXT/CCL2]

  1. ;;;
  2. ;;; resource-utils.Lisp
  3. ;;;
  4.  
  5. #|
  6. ================================================================
  7. Purpose ========================================================
  8. ================================================================
  9. Defines a LISP-style error-checked interface to the Resource Manager. The
  10. function definitions are organized as in Inside Macintosh VI.
  11.  
  12. Copyright © 1990-92 Matthew Cornell. All Rights Reserved. Send
  13. bugs, comments, questions, and fixes to cornell@cs.umass.edu.
  14.  
  15.  
  16. ================================================================
  17. Status =========================================================
  18. ================================================================
  19. Implemented for both 1.3.2 and 2.0b.
  20.  
  21. To do:
  22.  
  23. Return (#_ResError) ?
  24.  
  25. Implement other resource manager functions.
  26.  
  27. Provide a restart for open-resource-file to handle the file not being
  28.  found.
  29.  
  30. Get-resource should check for NIL being returned (ie it failed) and use
  31.  resource-error for the specific error:
  32.  
  33. More/better error checking (for example get-resource-info should check the
  34.  returned value using resource-error)
  35.  
  36.  
  37. ================================================================
  38. Change history =================================================
  39. ================================================================
  40. 22-Jan-90 mc    Created (Matthew Cornell).
  41.  6-Jul-90 mc    Changed functions passing ostypes to use :ostype
  42.         type keyword. <- didn't work:
  43.  
  44.   ? (_CountResources :ostype "PICT" :word)
  45.   2
  46.   ? (let ((type "PICT")) (_CountResources :ostype type :word))
  47.   0
  48.  
  49.  6-jul-90 mc    Fixed get-indexed-type
  50. 12-jul-90 mc    Added get-named-resource and load-resource
  51.  8-aug-90 mc    Added size-resource and get-resource-info
  52.         Added check-h-resource
  53.         Added test/sample code at end
  54.         Modified open-resource-file to use *open-resource-files*. This
  55.          allows enables closing all resource files (passing 0 to
  56.          close-resource-file) and allows close-resource-file to take either
  57.          a ref-num or the original file.
  58.         Using CCL package.
  59. 28-aug-90 mc    Added print-info-resource-type and print-info-all-resource-types
  60.          (removed from commented demo code ), and exported them.
  61.  2-Jul-91 mc    Added conditionalization for :CCL-1 and :CCL-2.
  62.  3-Jul-91 mc    Defined current-resource-file and use-resource-file.
  63.  3-Jul-91 mc    Defined create-resource-file.
  64. 14-Dec-91 mc    Changed name to Resource-utils.Lisp to avoid a conflict with
  65.          Apple's resources.Lisp (for version 2.0ß4).
  66. 14-Jan-92 mc    Defined reopen-resource-files, which is saved on
  67.          *restore-lisp-functions* so that open resource files will be
  68.          reopened when images are restarted. Issue: should
  69.          open-resource-file push the pathname it was passed or the full
  70.          pathname onto *open-resource-files* ? Decided on the passed
  71.          one.
  72. 30-Jan-92 mc    Added (reverse *open-resource-files*) to reopen-resource-files
  73.          so that the would be reopened in the right order.
  74. 29-Feb-92 mc    Defined get-resource-smart .
  75. 19-Mar-92 mc    Removed traps requirement (now uses less memory but
  76.          2.0-dependent).
  77. 29-Mar-92 mc    Defined and exported with-resource-file, update-resource-file,
  78.          add-resource, remove-resource .
  79.         Cleaned up the alist-entry adt.
  80. 16-Jul-92 mc    Changed open-resource-file to require a string for file-name
  81.          because it errored on pathnames.
  82. 19-Jul-92 mc    Changed open-resource-file back to a defun (it was causing an
  83.          error when it clashed with Apple's version, which was not a
  84.         generic function).
  85. 21-Jul-92 mc    Defined close-all-resource-files, as suggested by
  86.          neves@ils.nwu.EDU (thank you!).
  87.         Incorporated count1-resources and get1-indexed-resource, sent by
  88.          neves@ils.nwu.EDU .
  89.         Converted to using keywords to name resource types instead
  90.          of strings. This is consistent with mcl2.0's use of
  91.          resource types (for example %get-ostype returns a keyword), but
  92.          is a compatibility break. Case is significant when identifying
  93.          resource types; use :|snd |, :|PICT|, etc. to keep keywords in
  94.          their case.
  95.         Removed first-resource-word and second-resource-word . The
  96.          functionality is handled directly by 2.0's improved trap call
  97.          mechanism.
  98. 16-Aug-92 mc    SERIOUS problem: turning on balloon help causes errors because
  99.          it calls the old open-resource-file. In general we can't
  100.          shadow Apple's functions because mcl depends on them.
  101.          Solution1: Put all these files in a "RESOURCE-UTILS"
  102.          package. Solution2: change this file's functions names.
  103.          Decision: Use Solution1, knowing it's a compatibility break:
  104.         Changed package to "RESOURCE-UTILS" .
  105.         Fixed provide to use "RESOURCE-UTILS" (conflicted with Apple's).
  106.         Removed "CCL" from "RESOURCE-UTILS"'s :use list, to fix conflict.
  107.  
  108. |#
  109.  
  110.  
  111.  
  112. (in-package "CL-USER")                  ;temporary so we won't get a no
  113.                                         ; package error
  114.  
  115.  
  116. ;;; Define the package.
  117.  
  118. (defpackage "RESOURCE-UTILS" (:nicknames "RU")
  119.   (:use "COMMON-LISP")
  120.   (:shadow OPEN-RESOURCE-FILE CLOSE-RESOURCE-FILE USE-RESOURCE-FILE
  121.            CURRENT-RESOURCE-FILE GET-RESOURCE LOAD-RESOURCE ADD-RESOURCE
  122.            REMOVE-RESOURCE))
  123.  
  124.  
  125. (in-package "RESOURCE-UTILS")
  126.  
  127.  
  128. (export '(RESOURCE-ERROR
  129.           CREATE-RESOURCE-FILE
  130.           OPEN-RESOURCE-FILE
  131.           CLOSE-RESOURCE-FILE
  132.           CLOSE-ALL-RESOURCE-FILES
  133.           WITH-RESOURCE-FILE
  134.           CURRENT-RESOURCE-FILE
  135.           USE-RESOURCE-FILE
  136.           COUNT-TYPES
  137.           GET-INDEXED-TYPE
  138.           COUNT-RESOURCES
  139.           GET-INDEXED-RESOURCE
  140.           GET-RESOURCE
  141.           GET-RESOURCE-SMART
  142.           GET-NAMED-RESOURCE
  143.           LOAD-RESOURCE
  144.           COUNT1-RESOURCES
  145.           GET1-INDEXED-RESOURCE
  146.           GET-RESOURCE-INFO
  147.           SIZE-RESOURCE
  148.           ADD-RESOURCE
  149.           REMOVE-RESOURCE
  150.           UPDATE-RESOURCE-FILE
  151.           ;;
  152.           PRINT-INFO-RESOURCE-TYPE
  153.           PRINT-INFO-ALL-RESOURCE-TYPES)
  154.         "RU")
  155.  
  156.  
  157. ;;;====================================================================
  158. ;;;Parameters =========================================================
  159. ;;;====================================================================
  160.  
  161. (defvar *open-resource-files* ()
  162.   "An alist of the form ((pathname1 . ref-num1) ...) managed by
  163. open-resource-file, close-resource-file, and reopen-resource-files . Each
  164. pathname is the namestring as passed to open-resource-file, not the
  165. expanded pathname.")
  166.  
  167.  
  168. ;;;====================================================================
  169. ;;;Checking for errors ================================================
  170. ;;;====================================================================
  171.  
  172. (defun resource-error ()
  173.   "Used by some resource functions; 0 means no error."
  174.   ;;
  175.   (#_ResError :word))
  176.  
  177.  
  178. (defmacro check-resource-type (kw-resource-type)
  179.   "Ensures kw-resource-type is a keyword whose string is 4 characters long
  180. and errors if it isn't."
  181.   ;;
  182.   `(unless (and (keywordp ,kw-resource-type)
  183.                 (= (length (string ,kw-resource-type)) 4))
  184.      (error "~S not a proper resource type" ,kw-resource-type)))
  185.  
  186.  
  187. (defmacro check-h-resource (h-resource)
  188.   "Ensures h-resource is handlep, calling error if not."
  189.   ;;
  190.   `(unless (ccl::handlep ,h-resource)
  191.      (error "~S not a handle" ,h-resource)))
  192.  
  193.  
  194. ;;;====================================================================
  195. ;;;Support functions ==================================================
  196. ;;;====================================================================
  197.  
  198. (defmacro full-file-name (str-file-name)
  199.   `(namestring (ccl::full-pathname ,str-file-name)))
  200.  
  201.  
  202. ;;;====================================================================
  203. ;;;Define functions for handling the alist-entry abstract data type. ==
  204. ;;;====================================================================
  205.  
  206. (defun make-alist-entry (string-filename int-ref-num)
  207.   "Returns a new alist-entry that encodes string-filename and int-ref-num."
  208.   ;;
  209.   (cons string-filename int-ref-num))
  210.  
  211.  
  212. (defun filename-alist-entry (alist-entry)
  213.   "Returns alist-entry's filename."
  214.   ;;
  215.   (car alist-entry))
  216.  
  217.  
  218. (defun refnum-alist-entry (alist-entry)
  219.   "Returns alist-entry's refnum."
  220.   ;;
  221.   (cdr alist-entry))
  222.  
  223.  
  224. (defun refnum/filename->alist-entry (refnum-or-filename)
  225.   "Returns the alist-entry on *open-resource-files* corresponding to
  226. refnum-or-filename, which is an integer or a string. Errors if
  227. refnum-or-filename identifies a file that does not identify an entry on
  228. *open-resource-files* ."
  229.   ;;
  230.   (let ((alist-entry
  231.          (etypecase refnum-or-filename
  232.            (integer (rassoc refnum-or-filename *open-resource-files*))
  233.            ;; Following was (full-file-name refnum-or-filename):
  234.            (string (assoc refnum-or-filename
  235.                           *open-resource-files* :test #'equal)))))
  236.     (unless alist-entry
  237.       (error "~S does not identify a resource file opened by open-resource-file."
  238.              refnum-or-filename))
  239.     alist-entry))
  240.  
  241.  
  242. ;;;====================================================================
  243. ;;;Opening and closing resource files =================================
  244. ;;;====================================================================
  245.  
  246. ;;;
  247. ;;; Interesting note: this dies (infinite GC) on HyperCard:
  248. ;;;
  249.  
  250. (defun create-resource-file (str-file-name)
  251.   "CreateResFile creates a resource file containing no resource data. If
  252. there's no file at all with the given name, it also creates an empty data
  253. fork for the file. If there's already a resource file with the given name
  254. \(that is, a resource fork that isn't empty), CreateResFile will do nothing
  255. and the ResError function will return an appropriate Operating System
  256. result code."
  257.   ;;
  258.   (ccl::with-pstrs ((file-name-ptr (full-file-name str-file-name)))
  259.     (#_CreateResFile :ptr file-name-ptr)))
  260.  
  261.  
  262. (defun open-resource-file (str-file-name)
  263.   "Opens the resource fork of str-file-name, saving the str-file-name
  264. and the reference number on *open-resource-files*. Returns ref-num with
  265. -1 meaning the file couldn't be opened. str-file-name is a logical or
  266. full pathname."
  267.   ;;
  268.   (check-type str-file-name string)
  269.   ;;
  270.   (let* ((full-file-name (full-file-name str-file-name))
  271.          (ref-num (ccl::with-pstrs ((file-name-ptr full-file-name))
  272.                     (#_OpenResFile :ptr file-name-ptr :word))))
  273.     ;;
  274.     ;; Remove any old dotted pairs corresponding to str-file-name and add a new
  275.     ;;  one, if the file was opened successfully.
  276.     ;;
  277.     (unless (= ref-num -1)
  278.       (when (assoc str-file-name *open-resource-files* :test #'equal)
  279.         (setf *open-resource-files*
  280.               (remove-if #'(lambda (open-file-name)
  281.                              (string-equal open-file-name str-file-name))
  282.                          *open-resource-files* :key #'filename-alist-entry)))
  283.       ;; Following was  (cons full-file-name ref-num):
  284.       (push (make-alist-entry str-file-name ref-num)
  285.             *open-resource-files*))
  286.     ref-num))
  287.   
  288.  
  289. (defun close-resource-file (refnum-or-filename)
  290.   "Closes the resource fork of the file corresponding to refnum-or-filename,
  291. returning a the result of resource-error."
  292.   ;;
  293.   (let* ((alist-entry (refnum/filename->alist-entry refnum-or-filename))
  294.          (int-refnum (refnum-alist-entry alist-entry)))
  295.     (setf *open-resource-files*
  296.           (if (zerop int-refnum)
  297.             ()
  298.             (remove alist-entry *open-resource-files* :test #'equal)))
  299.     (#_CloseResFile :word int-refnum)
  300.     (resource-error)))
  301.  
  302.  
  303. (defun close-all-resource-files ()
  304.   "Calls close-resource-file on all open resource files."
  305.   ;;
  306.   (dolist (alist-entry *open-resource-files*)
  307.     (close-resource-file (refnum-alist-entry alist-entry))))
  308.  
  309.  
  310. ;;;====================================================================
  311. ;;;Setting the current resource file ==================================
  312. ;;;====================================================================
  313.  
  314. (defmacro with-resource-file ((refnum-or-filename) &rest body)
  315.   "Executes body with the current resource file set to refnum-or-filename
  316. via use-resource-file. An unwind-protect resets the current resource
  317. file to what it was."
  318.   ;;
  319.   (let ((sym-temp (gentemp)))
  320.     `(let ((,sym-temp (current-resource-file)))
  321.        (unwind-protect
  322.          (progn
  323.            (use-resource-file ,refnum-or-filename)
  324.            ,@body)
  325.          (use-resource-file ,sym-temp)))))
  326.  
  327.  
  328. (defun current-resource-file ()
  329.   "CurResFile returns the reference number of the current resource file."
  330.   ;;
  331.   (#_CurResFile :word))
  332.  
  333.  
  334. (defun use-resource-file (refnum-or-filename)
  335.   "Given the reference number of a resource file, UseResFile sets the
  336. current resource file to that file. If there's no resource file open with
  337. the given reference number, UseResFile will do nothing and the ResError
  338. function will return the result code resFNotFound. A refNum of 0 represents
  339. the system resource file."
  340.   ;;
  341.   (#_UseResFile :word (refnum-alist-entry (refnum/filename->alist-entry refnum-or-filename)))
  342.   (resource-error))
  343.  
  344.  
  345. ;;;====================================================================
  346. ;;;Getting resource types =============================================
  347. ;;;====================================================================
  348.  
  349. (defun count-types ()
  350.   "Returns the number of resource types in all open resource files."
  351.   ;;
  352.   (#_CountTypes :word))
  353.  
  354.  
  355. (defun get-indexed-type (index)
  356.   "Given an index ranging from 1 to CountTypes (above), GetIndType returns
  357. a resource type in theType. Called repeatedly over the entire range for the
  358. index, it returns all the resource types in all open resource files. If the
  359. given index isn’t in the range from 1 to CountTypes, GetIndType returns
  360. four NULL characters (ASCII code 0)."
  361.   ;;
  362.   (ccl::%stack-block ((res-type-ptr 4))
  363.     (#_GetIndType :ptr res-type-ptr :word index)
  364.     (ccl::%get-ostype res-type-ptr)))
  365.  
  366.  
  367. ;;;====================================================================
  368. ;;;Getting and disposing of resources =================================
  369. ;;;====================================================================
  370.  
  371. (defun count-resources (kw-resource-type)
  372.   "CountResources returns the total number of resources of the given type
  373. in all open resource files."
  374.   ;;
  375.   (check-resource-type kw-resource-type)
  376.   (#_CountResources kw-resource-type))
  377.  
  378.  
  379. (defun get-indexed-resource (kw-resource-type index)
  380.   "Given an index ranging from 1 to CountResources(theType), GetIndResource
  381. returns a handle to a resource of the given type (see CountResources, above).
  382. Called repeatedly over the entire range for the index, it returns handles to
  383. all resources of the given type in all open resource files. GetIndResource
  384. reads the resource data into memory if it’s not already in memory, unless
  385. you’ve called SetResLoad(FALSE)."
  386.   ;;
  387.   (check-resource-type kw-resource-type)
  388.   (#_GetIndResource kw-resource-type index))
  389.  
  390.  
  391. (defun get-resource (kw-resource-type resource-number)
  392.   "Returns a handle to the resource-number'th resource of type
  393. kw-resource-type."
  394.   ;;
  395.   (check-resource-type kw-resource-type)
  396.   (unless (numberp resource-number)
  397.     (error "~S not a number" resource-number))
  398.   (#_GetResource kw-resource-type resource-number))
  399.  
  400.  
  401. (defun get-named-resource (kw-resource-type resource-name)
  402.   "Returns a handle to the resource of type kw-resource-type named
  403. resource-name."
  404.   ;;
  405.   (check-resource-type kw-resource-type)
  406.   (ccl::with-pstrs ((resource-name-ptr resource-name))
  407.     (#_GetNamedResource kw-resource-type resource-name-ptr)))
  408.  
  409.  
  410. (defun load-resource (h-resource)
  411.   "Ensures the resource referenced by h-resource is in memory.
  412. S/call resource-error?."
  413.   ;;
  414.   (check-h-resource h-resource)
  415.   (#_LoadResource :ptr h-resource)    ;should dereference!?
  416.   )
  417.  
  418.  
  419. (defun count1-resources (kw-resource-type)
  420.   "Count1Resources returns the total number of resources of
  421. kw-resource-type in the current resource file."
  422.   ;;
  423.   (check-resource-type kw-resource-type)
  424.   (#_Count1Resources kw-resource-type))
  425.  
  426.  
  427. (defun get1-indexed-resource (kw-resource-type index)
  428.   "Given an index ranging from 1 to CountResources(theType),
  429. GetIndResource returns a handle to a kw-resource-type resource (see
  430. CountResources, above). Called repeatedly over the entire range for the
  431. index, it returns handles to all resources of the given type in the
  432. current resource file. Get1IndResource reads the resource data into
  433. memory if it's not already in memory, unless you've called
  434. SetResLoad(FALSE)."
  435.   ;;
  436.   (check-resource-type kw-resource-type)
  437.   (#_Get1IndResource kw-resource-type index))
  438.  
  439.  
  440. ;;;====================================================================
  441. ;;;Getting resource information =======================================
  442. ;;;====================================================================
  443.  
  444. (defun get-resource-info (h-resource)
  445.   "Returns values id-number type and name of the resource referenced by
  446. h-resource."
  447.   ;;
  448.   (check-h-resource h-resource)
  449.   (ccl::%stack-block ((id-ptr 2)
  450.                       (type-ptr 4)
  451.                       (name-ptr 256)    ;right?
  452.                       )
  453.     (#_GetResInfo :ptr h-resource :ptr id-ptr :ptr type-ptr :ptr name-ptr)
  454.     (let ((error-code (resource-error)))
  455.       (cond ((zerop error-code)
  456.              (values (ccl::%get-word id-ptr)
  457.                      (ccl::%get-ostype type-ptr)
  458.                      (ccl::%get-string name-ptr)))
  459.             (t (error "Code: ~A" error-code))))))
  460.  
  461.  
  462. (defun size-resource (h-resource)
  463.   "Returns the size of the resource referenced by h-resource in bytes."
  464.   ;;
  465.   (check-h-resource h-resource)
  466.   (#_SizeResource :ptr h-resource :long))
  467.  
  468.  
  469. ;;;====================================================================
  470. ;;;Modifying resources ================================================
  471. ;;;====================================================================
  472.  
  473. (defun add-resource (h-data kw-resource-type int-id str-name)
  474.   ;;
  475.   (check-resource-type kw-resource-type)
  476.   (check-h-resource h-data)
  477.   (ccl::with-pstrs ((p-name str-name))
  478.     (#_AddResource h-data kw-resource-type int-id p-name)))
  479.  
  480.  
  481. (defun remove-resource (h-resource)
  482.   ;;
  483.   (check-h-resource h-resource)
  484.   (#_RmveResource h-resource))
  485.  
  486.  
  487. (defun update-resource-file (refnum-or-filename)
  488.   ;;
  489.   (#_UpdateResFile :word (refnum-alist-entry (refnum/filename->alist-entry refnum-or-filename)))
  490.   (resource-error))
  491.  
  492.  
  493. ;;;====================================================================
  494. ;;;Resource printing functions ========================================
  495. ;;;====================================================================
  496.  
  497. (defun print-info-resource-type (kw-resource-type)
  498.   "Prints information about all resources of type kw-resource-type"
  499.   ;;
  500.   (let* ((number (count-resources kw-resource-type))
  501.          id-number type name)
  502.     (format t "~&~S resources of type ~S" number kw-resource-type)
  503.     (dotimes (i number)
  504.       (multiple-value-setq (id-number type name)
  505.         (get-resource-info (get-indexed-resource kw-resource-type (1+ i))))    
  506.       (format t "~&~S:~5T~S~10T~S~20T~S" (1+ i) id-number type name))))
  507.  
  508.  
  509. (defun print-info-all-resource-types ()
  510.   "Prints information about all resource types."
  511.   ;;
  512.   (let (resource number)
  513.     (dotimes (i (count-types))
  514.       (setf resource (get-indexed-type (1+ i))
  515.             number (count-resources resource))
  516.       (format t "~&~S~4Tresource~P of type~23T~S" number number
  517.               resource))))
  518.  
  519.  
  520. ;;;====================================================================
  521. ;;;Utilities ==========================================================
  522. ;;;====================================================================
  523.  
  524. (defmacro get-resource-smart (kw-resource-type id)
  525.   "Expands to get-resource if id is an integer or get-named-resource if id
  526. is a string. Note: the args may be evaluated more than once."
  527.   ;;
  528.   `(typecase ,id
  529.      (integer (get-resource ,kw-resource-type ,id))
  530.      (string (get-named-resource ,kw-resource-type ,id))))
  531.  
  532.  
  533. ;;;====================================================================
  534. ;;;Image save/restore functions =======================================
  535. ;;;====================================================================
  536.  
  537. (defun reopen-resource-files ()
  538.   "Calls open-resource-file on each filename saved on
  539. *open-resource-files*."
  540.   ;;
  541.   (map nil #'(lambda (open-file-alist-entry)
  542.                (open-resource-file (filename-alist-entry open-file-alist-entry)))
  543.        (reverse *open-resource-files*)))
  544.  
  545.  
  546. (pushnew #'reopen-resource-files ccl::*restore-lisp-functions*
  547.          :key #'ccl::function-name)
  548.  
  549.  
  550. ;;;
  551.  
  552. (ccl::provide "RESOURCE-UTILS")